home *** CD-ROM | disk | FTP | other *** search
/ Shareware Grab Bag / Shareware Grab Bag.iso / 050 / madtrb4.arc / FILEATTR.PAS < prev    next >
Pascal/Delphi Source File  |  1984-12-19  |  2KB  |  72 lines
  1. {@@@@@@@@@@@ copyright (C) 1984 by Neil J. Rubenking @@@@@@@@@@@@@@@@@@@@@@@@
  2. The purchaser of these procedures and functions may include them in COMPILED
  3. programs freely, but may not sell or give away the source text.
  4. }
  5. {$I regpack.typ}
  6. {$I filename.typ}
  7. {$I fileattr.lib}
  8. {$I errmessg.lib}
  9.  
  10. type
  11.   AttString = string[6];
  12.   CharSet   = set of char;
  13. const
  14.   AttChars : charset = ['R','H','S','V','D','A'];
  15.  
  16. var
  17.   this_file : filename_type;
  18.   error, N,
  19.   this_attribute : byte;
  20.   char_attributes : AttString;
  21. {@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@}
  22. function convert(attribute:byte):AttString;
  23. var
  24.   temp : attString;
  25. begin
  26.   temp := '      ';
  27.   if attribute and 1 = 1 then temp[1] := 'R';
  28.   if attribute and 2 = 2 then temp[2] := 'H';
  29.   if attribute and 4 = 4 then temp[3] := 'S';
  30.   if attribute and 8 = 8 then temp[4] := 'V';
  31.   if attribute and 16 = 16 then temp[5] := 'D';
  32.   if attribute and 32 = 32 then temp[6] := 'A';
  33.   convert := temp;
  34. end;
  35. {@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@}
  36. function UnConvert(atts : attString):byte;
  37. var
  38.   temp : byte;
  39. begin
  40.   temp := 0;
  41.   if pos('R',atts) <> 0 then temp := temp + 1;
  42.   if pos('H',atts) <> 0 then temp := temp + 2;
  43.   if pos('S',atts) <> 0 then temp := temp + 4;
  44.   if pos('V',atts) <> 0 then temp := temp + 8;
  45.   if pos('D',atts) <> 0 then temp := temp + 16;
  46.   if pos('A',atts) <> 0 then temp := temp + 32;
  47.   UnConvert := temp;
  48. end;
  49. {@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@}
  50. begin
  51.   WriteLn('Enter the name and full path of file to be changed.');
  52.   ReadLn(this_file);
  53.   FileAttribute('R',this_file,this_attribute,error);
  54.   if error = 0 then
  55.     begin
  56.       WriteLn('Current attributes are ',Convert(this_attribute));
  57.       WriteLn('Enter new attributes--[R]ead only, [H]idden, [S]ystem,[A]rchive');
  58.       read(char_attributes);
  59.       for N := 1 to length(char_attributes) do
  60.          char_attributes[N] := UpCase(char_attributes[N]);
  61.       this_attribute := UnConvert(char_attributes);
  62.       FileAttribute('W',this_file,this_attribute,error);
  63.       if error = 0 then
  64.         begin
  65.           WRite('Sucessfully changed the attribute of ',this_file);
  66.           WriteLn(' to ',convert(this_attribute),'.');
  67.         end
  68.       else WriteLn(message(error));
  69.     end
  70.   else WriteLn(message(error));
  71. end.
  72.